home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / PROGRAM / VIS082S.ARJ / FASTTTT5.PAS < prev    next >
Pascal/Delphi Source File  |  1989-09-30  |  12KB  |  423 lines
  1. {--------------------------------------------------------------------------}
  2. {                         TechnoJock's Turbo Toolkit                       }
  3. {                                                                          }
  4. {                              Version   5.02                              }
  5. {                                                                          }
  6. {                                                                          }
  7. {              Copyright 1986, 1989 TechnoJock Software, Inc.              }
  8. {                           All Rights Reserved                            }
  9. {                          Restricted by License                           }
  10. {--------------------------------------------------------------------------}
  11.  
  12.                      {--------------------------------}                                       
  13.                      {       Unit:  FastTTT5          }
  14.                      {--------------------------------}
  15.  
  16. { Update History:  4/01/89 5.00a    Changed VertLine and Horizline  
  17.                            5.01a    Added DEBUG compiler directive
  18.  
  19. }
  20.  
  21. {$S-,R-,V-}
  22. {$IFNDEF DEBUG}
  23. {$D-}
  24. {$ENDIF}
  25.  
  26. unit FastTTT5;
  27.  
  28. interface
  29.  
  30. Uses DOS, CRT;
  31.  
  32. const
  33.     MaxScreenStr = 80;
  34.     FCol:byte = white;
  35.     BCol:byte = black;
  36. type
  37.   StrScreen = string[MaxScreenStr];
  38. var
  39.   BaseOfScreen : Word;       {Base address of video memory}
  40.   VSeg : word;               {Base address of active screen}
  41.   VOfs : word;                   {Base address of active screen}
  42.   SnowProne : Boolean;       {Check for snow on color cards?}
  43.   Speed : longint;           {delay factor for growbox routine}
  44.  
  45. Function  ColorScreen:boolean;
  46. Function  Attr(F,B:byte):byte;
  47. Procedure FastWrite(Col,Row,Attr:byte; St:StrScreen);
  48. Procedure PlainWrite(Col,Row:byte; St:StrScreen);
  49. Procedure ColWrite(Col,Row:byte; St:StrScreen);
  50. Procedure FWrite(St:StrScreen);
  51. Procedure FWriteLN(St:StrScreen);
  52. Procedure Attrib(X1,Y1,X2,Y2,F,B:byte);
  53. Procedure Clickwrite(Col,Row,F,B:byte; St:StrScreen);
  54. Function  Replicate(N:byte; Character:char):StrScreen;
  55. Procedure Box(X1,Y1,X2,Y2,F,B,boxtype:integer);
  56. Procedure FBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  57. Procedure GrowFBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  58. Procedure HorizLine(X1,X2,Y,F,B,lineType:byte);
  59. Procedure VertLine(X,Y1,Y2,F,B,lineType:byte);
  60. Procedure ClearText(x1,y1,x2,y2,F,B:integer);
  61. Procedure ClearLine(Y,F,B:integer);
  62. Procedure WriteAT(X,Y,F,B:integer; St:StrScreen);
  63. Procedure WriteBetween(X1,X2,Y,F,B:byte; St:StrScreen);
  64. Procedure WriteCenter(LineNO,F,B:integer; St:StrScreen);
  65. Procedure WriteVert(X,Y,F,B:integer; St:StrScreen);
  66. Function  EGAVGASystem: boolean;
  67. Procedure InitFastTTT;
  68.  
  69. implementation
  70.  
  71.   {$L FASTTTT5}
  72.  
  73.   {$F+}
  74.   Procedure FastWrite(Col,Row,Attr:byte; St:StrScreen); external;
  75.   Procedure PlainWrite(Col,Row:byte; St:StrScreen); external;
  76.   Procedure Attribute(Col,Row,Attr:byte; Number:Word); external;
  77.   {$F-}
  78.  
  79.   Function ColorScreen: boolean;
  80.   {}
  81.   begin
  82.       ColorScreen := (BaseOfScreen = $B800);
  83.   end; {of func ColorScreen}
  84.  
  85.   Function Attr(F,B:byte):byte;
  86.   {converts foreground(F) and background(B) colors to combined Attribute byte}
  87.   begin
  88.       Attr := (B Shl 4) or F;
  89.   end;  {Func Attr}
  90.  
  91.   Procedure ColWrite(Col,Row:byte; St:StrScreen);
  92.   begin
  93.       Fastwrite(Col,Row,attr(FCol,BCol),St);
  94.   end;
  95.  
  96.   Procedure FWrite(St:StrScreen);
  97.   var Col,Row : byte;
  98.   begin
  99.       Col := WhereX;
  100.       Row := WhereY;
  101.       Fastwrite(Col,Row,attr(FCol,BCol),St);
  102.       GotoXY(Col+length(St),Row);
  103.   end;
  104.  
  105.   Procedure FWriteLN(St:StrScreen);
  106.   var Col,Row : byte;
  107.   begin
  108.       Col := WhereX;
  109.       Row := WhereY;
  110.       Fastwrite(Col,Row,attr(FCol,BCol),St);
  111.       GotoXY(1,succ(Row));
  112.   end;
  113.  
  114.   
  115.  
  116.   Procedure Attrib(X1,Y1,X2,Y2,F,B:byte);
  117.   {changes color attrib at specified coords}
  118.   var
  119.     I,X,A : byte;
  120.   begin
  121.       A := Attr(F,B);
  122.       X := Succ(X2-X1);
  123.       For I := Y1 to Y2 do
  124.           Attribute(X1,I,A,X);
  125.   end; {Proc Attrib}
  126.  
  127.  
  128.   Procedure Clickwrite(Col,Row,F,B:byte; St:StrScreen);
  129.   {writes text to the screen with a click!}
  130.   var
  131.     I : Integer;
  132.     L,A : byte;
  133.   begin
  134.       A := attr(F,B);
  135.       L := length(St);
  136.       For I := L downto 1 do
  137.       begin
  138.           Fastwrite(Col,Row,A,copy(St,I,succ(L-I)));
  139.           sound(500);delay(20);nosound;delay(30);
  140.       end;
  141.   end;
  142.  
  143.   Function Replicate(N : byte; Character:char):StrScreen;
  144.   {returns a string with Character repeated N times}
  145.   var tempstr : StrScreen;
  146.   begin
  147.       If N = 0 then
  148.          TempStr := ''
  149.       else
  150.       begin
  151.          If (N > 80) then
  152.             N := 1;
  153.          fillchar(tempstr,N+1,Character);
  154.          Tempstr[0] := chr(N);
  155.       end;
  156.       Replicate := Tempstr;
  157.   end;
  158.  
  159.   Procedure ClearText(x1,y1,x2,y2,F,B:integer);
  160.   var
  161.     Y : integer;
  162.     attrib : byte;
  163.   begin
  164.       If x2 > 80 then x2 := 80;
  165.       Attrib := attr(F,B);
  166.       For Y := y1 to y2 do
  167.           Fastwrite(X1,Y,attrib,replicate(X2-X1+1,' '));
  168.   end;   {cleartext}
  169.  
  170.   Procedure ClearLine(Y,F,B:integer);
  171.   begin
  172.       Fastwrite(1,Y,attr(F,B),replicate(80,' '));
  173.   end;
  174.  
  175.   Procedure Box(X1,Y1,X2,Y2,F,B,boxtype:integer);
  176.   {Draws a box on the screen}
  177.   var
  178.     I:integer;
  179.     corner1,corner2,corner3,corner4,
  180.     horizline,
  181.     vertline : char;
  182.     attrib : byte;
  183.   begin
  184.       case boxtype of
  185.       0:begin
  186.             corner1:=' ';
  187.             corner2:=' ';
  188.             corner3:=' ';
  189.             corner4:=' ';
  190.             horizline:=' ';
  191.             vertline:=' ';
  192.         end;
  193.       1:begin
  194.             corner1:='┌';
  195.             corner2:='┐';
  196.             corner3:='└';
  197.             corner4:='┘';
  198.             horizline:='─';
  199.             vertline:='│';
  200.         end;
  201.       2:begin
  202.             corner1:='╔';
  203.             corner2:='╗';
  204.             corner3:='╚';
  205.             corner4:='╝';
  206.             horizline:='═';
  207.             vertline:='║';
  208.         end;
  209.       3:begin
  210.             corner1:='╓';
  211.             corner2:='╖';
  212.             corner3:='╙';
  213.             corner4:='╜';
  214.             horizline:='─';
  215.             vertline:='║';
  216.         end;
  217.       4:begin
  218.             corner1:='╒';
  219.             corner2:='╕';
  220.             corner3:='╘';
  221.             corner4:='╛';
  222.             horizline:='═';
  223.             vertline:='│';
  224.         end;
  225.     else
  226.        corner1:=chr(ord(Boxtype));
  227.        corner2:=chr(ord(Boxtype));
  228.        corner3:=chr(ord(Boxtype));
  229.        corner4:=chr(ord(Boxtype));
  230.        horizline:=chr(ord(Boxtype));
  231.        vertline:=chr(ord(Boxtype));
  232.     end;{case}
  233.     attrib := attr(F,B);
  234.     FastWrite(X1,Y1,attrib,corner1);
  235.     FastWrite(X1+1,Y1,attrib,replicate(X2-X1-1,horizline));
  236.     FastWrite(X2,Y1,attrib,corner2);
  237.     For I := Y1+1 to Y2-1 do
  238.     begin
  239.         FastWrite(X1,I,attrib,vertline);
  240.         FastWrite(X2,I,attrib,vertline);
  241.     end;
  242.     FastWrite(X1,Y2,attrib,corner3);
  243.     FastWrite(X1+1,Y2,attrib,replicate(X2-X1-1,horizline));
  244.     FastWrite(X2,Y2,attrib,corner4);
  245.   end; {Proc Box}
  246.  
  247.   Procedure FBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  248.   {Draws a box and clears text within Box frame}
  249.   begin
  250.       Box(X1,Y1,X2,Y2,F,B,boxtype);
  251.       ClearText(succ(X1),succ(Y1),pred(X2),pred(Y2),F,B);
  252.   end;
  253.  
  254.   Procedure GrowFBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  255.   {Draws exploding filled box!}
  256.   var I,TX1,TY1,TX2,TY2,Ratio : integer;
  257.   begin
  258.       If 2*(Y2 -Y1 +1) > X2 - X1 + 1 then
  259.          Ratio :=   2
  260.       else
  261.          Ratio :=  1;
  262.       TX2 := (X2 - X1) div 2 + X1 + 2;
  263.       TX1 := TX2 - 3;                 {needs a box 3 by 3 minimum}
  264.       TY2 := (Y2 - Y1) div 2 + Y1 + 2;
  265.       TY1 := TY2 - 3;
  266.       If (X2-X1) < 3 then
  267.       begin
  268.          TX2 := X2;
  269.          TX1 := X1;
  270.       end;
  271.       If (Y2-Y1) < 3 then
  272.       begin
  273.          TY2 := Y2;
  274.          TY1 := Y1;
  275.       end;
  276.       repeat
  277.            FBox(TX1,TY1,TX2,TY2,F,B,BoxType);
  278.            If TX1 >= X1 + (1*Ratio) then TX1 := TX1 - (1*Ratio) else TX1 := X1;
  279.            If TY1 > Y1  then TY1 := TY1 - 1;
  280.            If TX2 + (1*Ratio) <= X2 then TX2 := TX2 + (1*Ratio) else TX2 := X2;
  281.            If TY2 + 1 <= Y2 then TY2 := TY2 + 1;
  282.            For I := 1 to Speed*1000 do {nothing};
  283.       Until (TX1 = X1) and (TY1 = Y1) and (TX2 = X2) and (TY2 = Y2);
  284.       FBox(TX1,TY1,TX2,TY2,F,B,BoxType);
  285.   end;
  286.  
  287.   procedure HorizLine(X1,X2,Y,F,B,lineType : byte);
  288.   var
  289.     I : integer;
  290.     Horizline : char;
  291.     attrib : byte;
  292.   begin
  293.       case LineType of                     {5.00a}
  294.       0       : HorizLine := ' ';
  295.       2,4,7,9 : Horizline := '═';
  296.       1,3,6,8 : HorizLine := '─';
  297.       else HorizLine := Chr(LineType);
  298.       end; {case}
  299.       Attrib := attr(F,B);
  300.       If X2 > X1 then
  301.          FastWrite(X1,Y,attrib,replicate(X2-X1+1,Horizline))
  302.       else
  303.          FastWrite(X1,Y,attrib,replicate(X1-X2+1,Horizline));
  304.   end;   {horizline}
  305.  
  306.   Procedure VertLine(X,Y1,Y2,F,B,lineType : byte);
  307.   var
  308.     I : integer;
  309.     vertline : char;
  310.     attrib : byte;
  311.   begin
  312.       case LineType of                {5.00a}
  313.       0       : VertLine := ' ';
  314.       2,4,7,9 : Vertline := '║';
  315.       1,3,6,8 : VertLine := '│';
  316.       else VertLine := Chr(LineType);
  317.       end; {case}
  318.       Attrib := attr(F,B);
  319.       If Y2 > Y1 then
  320.          For I := Y1 to Y2 do Fastwrite(X,I,Attrib,Vertline)
  321.       else
  322.          For I := Y2 to Y1 do Fastwrite(X,I,Attrib,Vertline);
  323.   end;   {vertline}
  324.  
  325.   Procedure WriteAT(X,Y,F,B:integer;St:StrScreen);
  326.   begin
  327.       Fastwrite(X,Y,attr(F,B),St);
  328.   end;
  329.  
  330.   Procedure WriteCenter(LineNO,F,B:integer;St:StrScreen);
  331.   begin
  332.       Fastwrite(40 - length(St) div 2,Lineno,attr(F,B),St);
  333.   end;
  334.  
  335.   Procedure WriteBetween(X1,X2,Y,F,B:byte;St:StrScreen);
  336.   var X : integer;
  337.   begin
  338.       If length(St) >= X2 - X1 + 1 then
  339.          WriteAT(X1,Y,F,B,St)
  340.       else
  341.       begin
  342.           x := X1 + (X2 - X1 + 1 - length(St)) div 2 ;
  343.           WriteAT(X,Y,F,B,St);
  344.       end;
  345.   end;
  346.  
  347.   Procedure WriteVert(X,Y,F,B:integer;ST : StrScreen);
  348.   var
  349.     I:integer;
  350.     Tempstr:StrScreen;
  351.   begin
  352.       If length(St) > 26 - Y then delete(St,27 - Y,80);
  353.       For I := 1 to length(St) do
  354.       begin
  355.           Tempstr := st[I];
  356.           Fastwrite(X,Y-1+I,attr(F,B),St[I]);
  357.       end;
  358.   end;
  359.  
  360.   Function EGAVGASystem: boolean;
  361.   {}
  362.   var  Regs : registers;
  363.   begin
  364.       with Regs do
  365.       begin
  366.           Ax := $1C00;
  367.           Cx := 7;
  368.           Intr($10,Regs);
  369.           If Al = $1C then  {VGA}
  370.           begin
  371.               EGAVGASystem := true;
  372.               exit;
  373.           end;
  374.           Ax := $1200;
  375.           Bl := $32;
  376.           Intr($10,Regs);
  377.           If Al = $12 then {MCGA}
  378.           begin
  379.               EGAVGASystem := true;
  380.               exit;
  381.           end;
  382.           Ah := $12;
  383.           Bl := $10;
  384.           Cx := $FFFF;
  385.           Intr($10,Regs);
  386.           EGAVGASystem := (Cx <> $FFFF);  {EGA}
  387.      end; {with}
  388.   end; {of func NoSnowSystem}
  389.  
  390.   Function Get_Video_Mode:byte;
  391.   {}
  392.   var
  393.      Regs : registers;
  394.   begin
  395.       with Regs do
  396.       begin
  397.           Ax := $0F00;
  398.           Intr($10,Regs);
  399.           Get_Video_Mode := Al;
  400.       end; {with}
  401.   end; {of proc Video_Mode}
  402.  
  403.   Procedure InitFastTTT;
  404.   begin
  405.       if Get_Video_Mode = 7 then
  406.       begin
  407.          BaseOfScreen := $B000;  {Mono}
  408.          SnowProne := False;
  409.       end
  410.       else
  411.       begin
  412.          BaseOfScreen := $B800; {Color}
  413.          SnowProne := not EGAVGASystem;
  414.       end;
  415.       VSeg := BaseOfScreen;
  416.       Vofs := 0;
  417.   end;
  418.  
  419. begin   {the following is always called when the unit is loaded}
  420.     InitFastTTT;
  421.     Speed := 200;
  422. end.
  423.